perm filename TANGLE.POS[TEX,ALS] blob
sn#621847 filedate 1981-10-23 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 PROGRAM tangle(input,output,pool,tty)
C00007 00003 PROCEDURE initialize
C00021 00004 PROCEDURE storetwobyte(x:sixteenbits)
C00033 00005 PROCEDURE flushbuffer
C00041 00006 PROCEDURE sendtheoutpu
C00049 00007 PROCEDURE getline
C00060 00008 PROCEDURE scannumeric(p:namepointer)
C00069 00009 PROCEDURE definemacro(t:eightbits)
C00077 ENDMK
C⊗;
PROGRAM tangle(input,output,pool,tty);
LABEL 9999;
CONST bufsize=100;
maxbytes=30000;
maxtoks=65535;
maxnames=4000;
maxtexts=2000;
hashsize=353;
longestname=300;
linelength=72;
outbufsize=144;
stacksize=50;
maxidlength=12;
unambiglengt=7;
TYPE asciifile=FILE OF char;
asciicode=0..127;
eightbits=0..255;
sixteenbits=0..65535;
namepointer=0..maxnames;
textpointer=0..maxtexts;
outputstate=
RECORD endfield:sixteenbits;
bytefield:sixteenbits;
namefield:namepointer;
replfield:textpointer;
END;
VAR pool:asciifile;
buffer:ARRAY[0..bufsize]OF asciicode;
phaseone:boolean;
bytemem:PACKED ARRAY[0..
maxbytes]OF asciicode;tokmem:PACKED ARRAY[0..maxtoks]OF eightbits;
bytestart:ARRAY[0..maxnames]OF sixteenbits;
tokstart:ARRAY[0..maxtexts]OF sixteenbits;
link:ARRAY[0..maxnames]OF sixteenbits;
ilk:ARRAY[0..maxnames] OF sixteenbits;
equiv:ARRAY[0..maxnames]OF sixteenbits;
textlink:ARRAY[0..maxtexts]OF sixteenbits;
nameptr:namepointer;
stringptr:namepointer;
byteptr:0..maxbytes;
textptr:textpointer;
tokptr:0..maxtoks;
maxtokptr:0..maxtoks;
idfirst:0..bufsize;
idloc:0..bufsize;
doublechars:0..bufsize;
hash,chophash:ARRAY[0..hashsize]OF sixteenbits;
choppedid:ARRAY[0..unambiglengt]OF asciicode;
module:ARRAY[0..
longestname]OF asciicode;
lastunnamed:textpointer;
curstate:
outputstate;
stack:ARRAY[1..stacksize]OF outputstate;
stackptr:0..
stacksize;
bracelevel:eightbits;
curval:integer;
outbuf:ARRAY[0..outbufsize]OF asciicode;
outptr:0..outbufsize;
breakptr:0..outbufsize;
outstate:eightbits;
outval,outapp:integer;
outsign:asciicode;
outcontrib:ARRAY[1..linelength]OF asciicode;
page:sixteenbits;
line:
sixteenbits;
limit:0..bufsize;
loc:0..bufsize;
inputhasende:boolean;
curmodule:namepointer;
nextcontrol:eightbits;
currepltext:
textpointer;
modulecount:0..12287;
debug troubleshoot:boolean;
ddt:sixteenbits;
dd:sixteenbits;
PROCEDURE help;
FORWARD;
PROCEDURE error;
VAR k,l:0..bufsize;
j:0..
outbufsize;
BEGIN
IF phaseone THEN
BEGIN
writeln(tty,'. (P.',page:0,',L.',line:0,')');
IF loc>=limit THEN l:=limit
ELSE l:=loc;
FOR k:=1 TO l
DO IF buffer[k-1]=9 THEN write(tty,' ')
ELSE write(tty,chr(buffer[k-1]));
writeln(tty,'');
FOR k:=1 TO l DO write(tty,' ');
FOR k:=l+1 TO limit DO
write(tty,chr(buffer[k-1]));
write(tty,' ');
END
ELSE
BEGIN
writeln(tty,'. (L.',line:0,')');
FOR j:=1 TO outptr DO write(tty,chr(outbuf[j-1]));
write(tty,'...');
END;
help;
END;
PROCEDURE quit;
BEGIN
GOTO 9999;
END;
PROCEDURE initialize;
VAR h:0..hashsize;
BEGIN
rewrite
(pool,'','/O');
IF NOT eof(pool)THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! COULDN''T OPEN THE POOL FILE.');
END;
quit;
END;
nameptr:=1;
stringptr:=128;
byteptr:=1;
bytestart[0]:=1;
bytestart[1]:=1;
tokptr:=1;
textptr:=1;
tokstart[0]:=1;
tokstart[1]:=1;
ilk[0]:=0;
equiv[0]:=0;
FOR h:=0
TO hashsize-1 DO
BEGIN
hash[h]:=0;
chophash[h]:=0;
END;
lastunnamed:=0;
textlink[0]:=0;
module[0]:=32;
debug troubleshoot:=true;
ddt:=9999;
END;
FUNCTION openinput:boolean;
BEGIN
reset(input,'','/E/I/O');
openinput:=eof(input);
END;
FUNCTION inputln:boolean;
BEGIN
readln;
IF eof(input)THEN inputln:=false
ELSE
BEGIN
limit:=0;
buffer[0]:=ord(input↑);
IF buffer[0]<>12 THEN
WHILE buffer[limit]<>13 DO
IF limit=bufsize-1 THEN
BEGIN
buffer[limit]:=13;
BEGIN
writeln(tty);
write(tty,'! INPUT LINE TOO LONG');
END;
error;
END
ELSE
BEGIN
limit:=limit+1;
get(input);
IF eof(input)THEN buffer[limit]:=13
ELSE buffer[limit]:=ord(input↑);
END;
inputln:=true;
END;
END;
PROCEDURE printid(p:namepointer);
VAR k:0..maxbytes;
BEGIN
IF p>=nameptr THEN write(tty,'IMPOSSIBLE')
ELSE FOR k:=
bytestart[p]TO bytestart[p+1]-1 DO write(tty,chr(bytemem[k]));
END;
FUNCTION idlookup(t:eightbits):namepointer;
LABEL 31,32;
VAR c:eightbits;
i:0..bufsize;
h:0..hashsize;
k:0..maxbytes;
l:0..bufsize;
p,q:namepointer;
s:0..unambiglengt;
BEGIN
l:=idloc-idfirst;
h:=buffer[idfirst];
i:=idfirst+1;
WHILE i<idloc DO
BEGIN
h:=(h+h+buffer[i])MOD hashsize;
i:=i+1;
END;
p:=hash[h];
WHILE p<>0 DO
BEGIN
IF bytestart[p+1]-bytestart[p]=l THEN
BEGIN
i:=idfirst;
k:=bytestart[p];
WHILE(i<idloc)AND(buffer[i]=bytemem[k])
DO
BEGIN
i:=i+1;
k:=k+1;
END;
IF i=idloc THEN GOTO 31;
END;
p:=link[p];
END;
p:=nameptr;
link[p]:=hash[h];
hash[h]:=p;
31:;
IF(p=nameptr)OR(t<>0)THEN
BEGIN
IF((p<>nameptr)AND(t<>0)AND(ilk[p]=0))
OR((p=nameptr)AND(t=0)AND(buffer[idfirst]<>34))THEN
BEGIN
i:=idfirst;
s:=0;
h:=0;
WHILE(i<idloc)
AND(s<unambiglengt)DO
BEGIN
IF buffer[i]<>24 THEN
BEGIN
IF buffer[i]>=97
THEN choppedid[s]:=buffer[i]-32
ELSE choppedid[s]:=buffer[i];
h:=(h+h+choppedid[s])MOD hashsize;
s:=s+1;
END;
i:=i+1;
END;
choppedid[s]:=0;
END;
IF p<>nameptr THEN
BEGIN
IF ilk[p]=0 THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! THIS IDENTIFIER HAS ALREADY APPEARED');
END;
error;
END;
q:=chophash[h];
IF q=p THEN chophash[h]:=equiv[p]
ELSE
BEGIN
WHILE equiv[q]<>p DO q:=equiv[q];
equiv[q]:=equiv[p];
END;
END
ELSE
BEGIN
BEGIN
writeln(tty);
write(tty,'! THIS IDENTIFIER WAS DEFINED BEFORE');
END;
error;
END;
ilk[p]:=t;
END
ELSE
BEGIN
IF(t=0)AND(buffer[idfirst]<>34)THEN
BEGIN
q:=chophash[h];
WHILE q<>0 DO
BEGIN
BEGIN
k:=bytestart[q];
s:=0;
WHILE(k<bytestart[q+1])AND(s<unambiglengt)DO
BEGIN
c:=bytemem[k];
IF c<>24 THEN
BEGIN
IF c>=97 THEN c:=c-32;
IF choppedid[s]<>c THEN GOTO 32;
s:=s+1;
END;
k:=k+1;
END;
IF(k=bytestart[q+1])AND(choppedid[s]<>0)THEN GOTO 32;
BEGIN
writeln(tty);
write(tty,'! IDENTIFIER CONFLICT WITH ');
END;
FOR k:=bytestart[q]TO bytestart[q+1]-1 DO
write(tty,chr(bytemem[k]));
error;
q:=0;
32:
END;
q:=equiv[q];
END;
equiv[p]:=chophash[h];
chophash[h]:=p;
END;
IF
byteptr+l>maxbytes THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','BYTE MEMORY',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
IF nameptr=maxnames THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','NAME',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
i:=idfirst;
k:=byteptr;
WHILE i<idloc DO
BEGIN
bytemem[k]:=buffer[i];
k:=k+1;
i:=i+1;
END;
byteptr:=k;
nameptr:=nameptr+1;
bytestart[nameptr]:=k;
IF buffer[
idfirst]<>34 THEN ilk[p]:=t
ELSE
BEGIN
ilk[p]:=1;
IF l-doublechars=2
THEN equiv[p]:=buffer[idfirst+1]+32768
ELSE
BEGIN
equiv[p]:=stringptr+32768;
stringptr:=stringptr+1;
write(pool,chr(31+l-doublechars));
i:=idfirst+1;
WHILE i<idloc DO
BEGIN
write(pool,chr(buffer[i]));
IF(buffer[i]
=34)OR(buffer[i]=64)THEN i:=i+2
ELSE i:=i+1;
END;
END;
END;
END;
END;
idlookup:=p;
END;
FUNCTION modlookup(l:sixteenbits):namepointer;
LABEL 31;
VAR
c:(less,equal,greater,prefix,extension);
j:0..longestname;
k:0..maxbytes;
p:namepointer;
q:namepointer;
BEGIN
c:=greater;
q:=0;
p:=ilk[0];
WHILE p<>0 DO
BEGIN
BEGIN
k:=bytestart[p];
c:=equal;
j:=1;
WHILE(k<bytestart[p+1])AND(
j<=l)AND(module[j]=bytemem[k])DO
BEGIN
k:=k+1;
j:=j+1;
END;
IF k=bytestart[p+1]THEN
IF j>l THEN c:=equal
ELSE c:=extension
ELSE IF j>l THEN c:=prefix
ELSE IF module[j]<bytemem[k]THEN c:=less
ELSE c:=greater;
END;
q:=p;
IF c=less THEN p:=link[q]
ELSE IF c=greater THEN p:=ilk[q]
ELSE GOTO 31;
END;
IF byteptr+l>maxbytes THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','BYTE MEMORY',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
IF nameptr=maxnames THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','NAME',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
p:=nameptr;
IF c=less THEN link[q]:=p
ELSE ilk[q]:=p;
link[p]:=0;
ilk[p]:=0;
c:=equal;
FOR j:=1 TO l DO bytemem[byteptr+j-1]:=module[j];
byteptr:=
byteptr+l;
nameptr:=nameptr+1;
bytestart[nameptr]:=byteptr;
31:
IF c<>equal
THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! INCOMPATIBLE MODULE NAMES');
END;
error;
END;
p:=0;
END;
modlookup:=p;
END;
FUNCTION prefixlookup(l:sixteenbits):namepointer;
LABEL 31;
VAR
c:(less,equal,greater,prefix,extension);
count:0..maxnames;
j:0..longestname;
k:0..maxbytes;
p:namepointer;
q:namepointer;
r:namepointer;
BEGIN
q:=0;
p:=ilk[0];
count:=0;
r:=0;
WHILE p<>0 DO
BEGIN
BEGIN
k:=bytestart[p];
c:=equal;
j:=1;
WHILE(k<bytestart[p+1])AND(j<=l)AND(module[j]=bytemem[k])DO
BEGIN
k:=k+1;
j:=j+1;
END;
IF k=bytestart[p+1]THEN
IF j>l THEN c:=equal
ELSE c:=extension
ELSE IF j>l THEN c:=prefix
ELSE IF module[j]<bytemem[k]THEN c:=less
ELSE c:=greater;
END;
IF c=less THEN p:=link[p]
ELSE IF c=greater THEN p:=ilk[p]
ELSE
BEGIN
r:=p;
count:=count+1;
q:=ilk[p];
p:=link[p];
END;
IF
p=0 THEN
BEGIN
p:=q;
q:=0;
END;
END;
IF count<>1 THEN
IF count=0 THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! NAME DOES NOT MATCH');
END;
error;
END
ELSE
BEGIN
BEGIN
writeln(tty);
write(tty,'! AMBIGUOUS PREFIX');
END;
error;
END;
prefixlookup:=r;
END;
PROCEDURE storetwobyte(x:sixteenbits);
BEGIN
IF tokptr+2>maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=x DIV 256;
tokmem[tokptr+1]:=x MOD 256;
tokptr:=tokptr+2;
END;
PROCEDURE printrepl(p:textpointer);
VAR k:0..maxtoks;
a:sixteenbits;
BEGIN
IF p>=textptr THEN write(tty,'BAD')
ELSE
BEGIN
k:=tokstart[p];
WHILE
k<tokstart[p+1]DO
BEGIN
a:=tokmem[k];
IF a>=128 THEN
BEGIN
k:=k+1;
IF a<168 THEN
BEGIN
a:=(a-128)*256+tokmem[k];
printid(a);
IF bytemem[bytestart[a]]=34 THEN
write(tty,'"')
ELSE write(tty,' ');
END
ELSE IF a<208 THEN
BEGIN
write(tty,'@<');
printid((a-168)*256+tokmem[k]);
write(tty,'@>');
END
ELSE
BEGIN
a:=(a-208)*256+tokmem[k];
write(tty,'@ ',a:0,'@',chr(126));
END;
END
ELSE CASE a OF
9:write(tty,'@ ');
10:write(tty,'@',chr(126));
12:write(tty,'@''');
13:write(tty,'#');
64:write(tty,'@@');
OTHERS:write(tty,chr(a))
END;
k:=k+1;
END;
END;
END;
PROCEDURE pushlevel(p:namepointer);
BEGIN
IF stackptr=stacksize THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(
tty,'! SORRY, ','STACK',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END
ELSE
BEGIN
stack[stackptr]:=curstate;
stackptr:=stackptr+1;
curstate.namefield:=p;
curstate.replfield:=equiv[p];
curstate.bytefield:=tokstart[
curstate.replfield];
curstate.endfield:=tokstart[curstate.replfield+1];
END;
END;
PROCEDURE poplevel;
LABEL 10;
BEGIN
IF textlink[curstate.replfield]=0 THEN
BEGIN
IF ilk[curstate.namefield]=3 THEN
BEGIN
IF tokptr>maxtokptr THEN maxtokptr:=tokptr;
nameptr:=nameptr-1;
textptr:=textptr-1;
tokptr:=tokstart[textptr];
byteptr:=byteptr-1;
END;
END
ELSE IF textlink[curstate.replfield]<maxtexts THEN
BEGIN
curstate.replfield:=textlink[curstate.replfield];
curstate.bytefield:=tokstart[curstate.replfield];
curstate.endfield:=tokstart[curstate.replfield+1];
GOTO 10;
END;
stackptr:=stackptr-1;
IF stackptr>0 THEN curstate:=stack[
stackptr];
10:
END;
FUNCTION getoutput:sixteenbits;
LABEL 20,30;
VAR a:
sixteenbits;
b:eightbits;
bal:sixteenbits;
BEGIN
20:
IF stackptr=0 THEN a:=0
ELSE
BEGIN
IF curstate.bytefield=curstate.endfield THEN
BEGIN
poplevel;
GOTO 20;
END;
a:=tokmem[curstate.bytefield];
curstate.bytefield:=curstate.bytefield+1;
IF a<128 THEN
BEGIN
IF a=13 THEN
BEGIN
pushlevel(nameptr-1);
GOTO 20;
END;
END
ELSE
BEGIN
a:=(a-128)*256+tokmem[curstate.bytefield];
curstate.bytefield:=curstate.bytefield+1;
IF a<10240 THEN
BEGIN
CASE
ilk[a]OF
0:
BEGIN
curval:=a;
a:=130;
END;
1:
BEGIN
curval:=equiv[a]-32768;
a:=128;
END;
2:
BEGIN
pushlevel(a);
GOTO 20;
END;
3:
BEGIN
WHILE(curstate.
bytefield=curstate.endfield)AND(stackptr>0)DO poplevel;
IF(stackptr=0)OR(tokmem[curstate.bytefield]<>40)THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! NO PARAMETER GIVEN FOR ');
END;
printid(a);
error;
GOTO 20;
END;
bal:=1;
curstate.bytefield:=curstate.bytefield+1;
WHILE true DO
BEGIN
b:=tokmem[curstate.bytefield];
curstate.bytefield:=curstate.bytefield+1;
IF b=13
THEN storetwobyte(nameptr+32767)
ELSE
BEGIN
IF b>=128 THEN
BEGIN
BEGIN
IF
tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=b;
tokptr:=tokptr+1;
END;
b:=tokmem[curstate.bytefield];
curstate.bytefield:=curstate.bytefield+1;
END
ELSE CASE b OF
40:bal:=bal+1;
41:
BEGIN
bal:=bal-1;
IF bal=0 THEN GOTO 30;
END;
39:REPEAT
BEGIN
IF tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=b;
tokptr:=tokptr+1;
END;
b:=tokmem[curstate.bytefield];
curstate.bytefield:=curstate.bytefield+1;
UNTIL b=39;
OTHERS:
END;
BEGIN
IF tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=b;
tokptr:=tokptr+1;
END;
END;
END;
30:;
equiv[nameptr]:=textptr;
ilk[nameptr]:=2;
IF byteptr=maxbytes THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','BYTE MEMORY',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
bytemem[byteptr]:=35;
byteptr:=byteptr+1;
IF nameptr=maxnames THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','NAME',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
nameptr:=nameptr+1;
bytestart[nameptr]:=byteptr;
IF textptr=maxtexts THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TEXT',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
textlink[textptr]:=0;
textptr:=textptr+1;
tokstart[textptr]:=tokptr;
pushlevel(a);
GOTO 20;
END;
OTHERS:
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! THIS CAN''T HAPPEN (','OUTPUT',')');
END;
error;
END;
quit;
END
END
END
ELSE IF a<20480 THEN
BEGIN
a:=a-10240;
IF equiv[a]<>0 THEN pushlevel(a)
ELSE
IF a<>0 THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! NOT PRESENT: <');
END;
printid(a);
write(tty,'>');
error;
END;
GOTO 20;
END
ELSE
BEGIN
curval:=a-20480;
a:=129;
END;
END;
END;
IF troubleshoot THEN debughelp;
getoutput:=a;
END;
PROCEDURE flushbuffer;
VAR k:0..outbufsize;
BEGIN
FOR k:=1 TO breakptr DO write(chr(outbuf[k-1]));
writeln;
line:=line+1;
IF line MOD 100=0 THEN write(tty,'.');
IF breakptr<outptr THEN
BEGIN
IF outbuf[breakptr]=32 THEN breakptr:=breakptr+1;
FOR k:=breakptr TO outptr-1 DO
outbuf[k-breakptr]:=outbuf[k];
END;
outptr:=outptr-breakptr;
breakptr:=0;
IF outptr>linelength THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! LONG LINE MUST BE TRUNCATED');
END;
error;
END;
outptr:=linelength;
END;
END;
PROCEDURE appval(v:integer);
VAR k:0..
outbufsize;
BEGIN
k:=outbufsize;
REPEAT outbuf[k]:=v MOD 10;
v:=v DIV 10;
k:=k-1;
UNTIL v=0;
REPEAT k:=k+1;
BEGIN
outbuf[outptr]:=outbuf[k]+48;
outptr:=outptr+1;
END;
UNTIL k=outbufsize;
END;
PROCEDURE sendout(t:eightbits;
v:sixteenbits);
LABEL 20;
VAR k:0..linelength;
BEGIN
20:
CASE outstate OF
1:IF t<>3 THEN
BEGIN
breakptr:=outptr;
IF t=2 THEN
BEGIN
outbuf[outptr]:=32;
outptr:=outptr+1;
END;
END;
2:
BEGIN
BEGIN
outbuf[outptr]:=44-outapp;
outptr:=outptr+1;
END;
IF outptr>linelength THEN flushbuffer;
breakptr:=outptr;
END;
3,4:
BEGIN
IF outval<0 THEN
BEGIN
outbuf[outptr]:=45;
outptr:=outptr+1;
END
ELSE IF outsign>0 THEN
BEGIN
outbuf[outptr]:=outsign;
outptr:=outptr+1;
END;
appval(abs(outval));
IF outptr>linelength THEN
flushbuffer;
outstate:=outstate-2;
GOTO 20;
END;
5:
BEGIN
IF(t=3)
OR(((t=2)AND(v=3)AND(((outcontrib[1]=68)
AND(outcontrib[2]=73)AND(outcontrib[3]=86))
OR((outcontrib[1]=77)AND(outcontrib[2]=79)
AND(outcontrib[3]=68))))OR((t=0)
AND((v=42)OR(v=47))))THEN
BEGIN
IF outval<0 THEN
BEGIN
outbuf[outptr]:=45;
outptr:=outptr+1;
END
ELSE IF outsign>0 THEN
BEGIN
outbuf[outptr]:=outsign;
outptr:=outptr+1;
END;
appval(abs(outval));
IF outptr>linelength THEN flushbuffer;
outsign:=43;
outval:=outapp;
END
ELSE
outval:=outval+outapp;
outstate:=3;
GOTO 20;
END;
0:IF t<>3 THEN breakptr:=outptr;
OTHERS:
END;
IF t<>0 THEN FOR k:=1 TO v DO
BEGIN
outbuf[outptr]:=outcontrib[k];
outptr:=outptr+1;
END
ELSE
BEGIN
outbuf[outptr]:=v;
outptr:=outptr+1;
END;
IF outptr>linelength THEN flushbuffer;
IF t>=2 THEN outstate:=1
ELSE outstate:=0
END;
PROCEDURE sendsign(v:integer);
BEGIN
CASE outstate OF
2,4:outapp:=outapp*v;
3:
BEGIN
outapp:=v;
outstate:=4;
END;
5:
BEGIN
outval:=outval+outapp;
outapp:=v;
outstate:=4;
END;
OTHERS:
BEGIN
breakptr:=outptr;
outapp:=v;
outstate:=2;
END
END;
END;
PROCEDURE sendval (v:integer);
LABEL 666,10;
BEGIN
CASE outstate OF
1:
BEGIN
IF(outptr=breakptr+3)OR((outptr=breakptr+4)
AND(outbuf[breakptr]=32))THEN
IF((outbuf[outptr-3]=68)AND(outbuf[outptr-2]=73)
AND(outbuf[outptr-1]=86))OR((outbuf[outptr-3]=77)
AND(outbuf[outptr-2]=79)AND(outbuf[outptr-1]=68)) THEN
GOTO 666;
outsign:=32;
outstate:=3;
outval:=v;
breakptr:=outptr;
END;
0:
BEGIN
IF(outptr=breakptr+1)AND((outbuf[breakptr]=42)
OR(outbuf[breakptr]=47))THEN GOTO 666;
outsign:=0;
outstate:=3;
outval:=v;
breakptr:=outptr;
END;
2:
BEGIN
outsign:=43;
outstate:=3;
outval:=outapp*v;
END;
3:
BEGIN
outstate:=5;
outapp:=v;
END;
4:
BEGIN
outstate:=5;
outapp:=outapp*v;
END;
5:
BEGIN
outval:=outval+outapp;
outapp:=v;
END;
OTHERS:GOTO 666
END;
GOTO 10;
666:
IF v>=0 THEN
BEGIN
IF outstate=1 THEN
BEGIN
breakptr:=outptr;
BEGIN
outbuf[outptr]:=32;
outptr:=outptr+1;
END;
END;
appval(v);
IF outptr>linelength THEN flushbuffer;
outstate:=1;
END
ELSE
BEGIN
BEGIN
outbuf[outptr]:=40;
outptr:=outptr+1;
END;
BEGIN
outbuf[outptr]:=45;
outptr:=outptr+1;
END;
appval(-v);
BEGIN
outbuf[outptr]:=41;
outptr:=outptr+1;
END;
IF outptr>linelength THEN flushbuffer;
outstate:=0;
END;
10:
END;
PROCEDURE sendtheoutpu;
LABEL 2,21,22;
VAR curchar:eightbits;
k:0..linelength;
j:0..maxbytes;
n:integer;
BEGIN
WHILE stackptr>0 DO
BEGIN
curchar:=getoutput;
21:
CASE curchar OF
0:;
65,66,67,68,69,70,71,72,73,74,75,76,77,
78,79,80,81,82,83,84,85,86,87,88,89,90:
BEGIN
outcontrib[1]:=curchar;
sendout(2,1);
END;
97,98,99,100,101,102,103,104,105,106,107,
108,109,110,111,112,113,114,115,116,117,
118,119,120,121,122:
BEGIN
outcontrib[1]:=curchar-32;
sendout(2,1);
END;
130:
BEGIN
k:=0;
j:=bytestart[curval];
WHILE(k<maxidlength
)AND(j<bytestart[curval+1])DO
BEGIN
k:=k+1;
outcontrib[k]:=bytemem[j];
j:=j+1;
IF outcontrib[k]>=97 THEN
outcontrib[k]:=outcontrib[k]-32
ELSE IF outcontrib[k]=24 THEN k:=k-1;
END;
sendout(2,k);
END;
48,49,50,51,52,53,54,55,56,57:
BEGIN
n:=0;
REPEAT n:=10*n+curchar-48;
curchar:=getoutput;
UNTIL(curchar>57)OR(curchar<48);
sendval(n);
k:=0;
IF curchar=101 THEN
curchar:=69;
IF curchar=69 THEN GOTO 2
ELSE GOTO 21;
END;
12:
BEGIN
n:=0;
curchar:=48;
REPEAT n:=8*n+curchar-48;
curchar:=getoutput;
UNTIL(curchar>55)OR(curchar<48);
sendval(n);
GOTO 21;
END;
128:sendval(curval);
46:
BEGIN
k:=1;
outcontrib[1]:=46;
curchar:=getoutput;
IF curchar=46 THEN
BEGIN
outcontrib[2]:=46;
sendout(1,2);
END
ELSE IF(curchar>=48)AND(curchar<=57) THEN GOTO 2
ELSE
BEGIN
sendout(0,46);
GOTO 21;
END;
END;
43,45:sendsign(44-curchar);
4:
BEGIN
outcontrib[1]:=65;
outcontrib[2]:=78;
outcontrib[3]:=68;
sendout(2,3);
END;
5:
BEGIN
outcontrib[1]:=78;
outcontrib[2]:=79;
outcontrib[3]:=84;
sendout(2,3);
END;
6:
BEGIN
outcontrib[1]:=73;
outcontrib[2]:=78;
sendout(2,2);
END;
31:
BEGIN
outcontrib[1]:=79;
outcontrib[2]:=82;
sendout(2,2);
END;
95:
BEGIN
outcontrib[1]:=58;
outcontrib[2]:=61;
sendout(1,2);
END;
27:
BEGIN
outcontrib[1]:=60;
outcontrib[2]:=62;
sendout(1,2);
END;
28:
BEGIN
outcontrib[1]:=60;
outcontrib[2]:=61;
sendout(1,2);
END;
29:
BEGIN
outcontrib[1]:=62;
outcontrib[2]:=61;
sendout(1,2);
END;
30:
BEGIN
outcontrib[1]:=61;
outcontrib[2]:=61;
sendout(1,2);
END;
32:
BEGIN
outcontrib[1]:=46;
outcontrib[2]:=46;
sendout(1,2);
END;
39:
BEGIN
k:=1;
outcontrib[1]:=39;
REPEAT
IF k<linelength THEN k:=k+1;
outcontrib[k]:=getoutput;
UNTIL(outcontrib[k]=39)OR(stackptr=0);
IF k=linelength THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! STRING TOO LONG');
END;
error;
END;
sendout(1,k);
curchar:=getoutput;
IF curchar=39 THEN outstate:=6;
GOTO 21;
END;
33,34,35,36,37,38,40,41,42,44,47,58,59,
60,61,62,63,64,91,92,93,94,24,96,123,124,126:
sendout(0,curchar);
9:
BEGIN
IF bracelevel=0 THEN sendout(0,123)
ELSE
sendout(0,91);
bracelevel:=bracelevel+1;
END;
10:IF bracelevel>0 THEN
BEGIN
bracelevel:=bracelevel-1;
IF bracelevel=0 THEN sendout(0,126)
ELSE sendout(0,93);
END
ELSE
BEGIN
BEGIN writeln(tty);
write(tty,'! EXTRA @↑');
END;
error;
END;
129:IF bracelevel=0 THEN
BEGIN
sendout(0,123);
sendval(curval);
sendout(0,126);
END
ELSE
BEGIN
sendout(0,91);
sendval(curval);
sendout(0,93);
END;
127:
BEGIN
sendout(3,0);
outstate:=6;
END;
OTHERS:
BEGIN
BEGIN
writeln(tty);
write(tty,'! CAN''T OUTPUT ASCII CODE ',curchar:0);
END;
error;
END
END;
GOTO 22;
2:
REPEAT
IF k<linelength THEN k:=k+1;
outcontrib[k]:=curchar;
curchar:=getoutput;
IF(outcontrib[k]=69)AND((curchar=43)
OR(curchar=45))THEN
BEGIN
IF k<linelength THEN k:=k+1;
outcontrib[k]:=curchar;
curchar:=getoutput;
END
ELSE IF curchar=101 THEN curchar:=69;
UNTIL(curchar<>69)AND((curchar<48)OR(curchar>57));
IF k=linelength THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! FRACTION TOO LONG');
END;
error;
END;
sendout(3,k);
GOTO 21;
22:
END;
END;
PROCEDURE getline;
BEGIN
IF buffer[0]=12 THEN line:=0;
IF inputln THEN
BEGIN
IF line=0 THEN
BEGIN
page:=page+1;
write(tty,page:0,' ');
IF(page=1)AND(limit=29)THEN
IF(buffer[0]=67)AND(buffer[8]=22)THEN
REPEAT
IF inputln THEN
ELSE
BEGIN
limit:=0;
buffer[0]:=12;
END;
UNTIL buffer[0]=1;
END;
IF buffer[limit]=13 THEN buffer[limit]:=32;
END
ELSE IF buffer[0]<>12 THEN
BEGIN
limit:=0;
buffer[0]:=12;
END
ELSE inputhasende:=true;
line:=line+1;
loc:=0;
END;
FUNCTION controlcode(c:asciicode):eightbits;
BEGIN
CASE c OF
64:
controlcode:=64;
39:controlcode:=12;
32,9,42:controlcode:=137;
84,116:
controlcode:=131;
68,100:controlcode:=133;
70,102:controlcode:=132;
123:
controlcode:=9;
126:controlcode:=10;
80,112:controlcode:=134;
38:
controlcode:=127;
60:controlcode:=135;
OTHERS:controlcode:=0
END;
END;
FUNCTION skipahead:eightbits;
LABEL 30;
VAR c:eightbits;
BEGIN
WHILE true DO
BEGIN
IF loc>limit THEN
BEGIN
getline;
IF buffer[0]=12 THEN
BEGIN
loc:=1;
c:=136;
GOTO 30;
END;
END;
buffer[limit+1]:=64;
WHILE buffer[loc]<>64 DO
loc:=loc+1;
IF loc<=limit THEN
BEGIN
loc:=loc+2;
c:=controlcode(buffer[loc-1]);
IF(c<>0)OR(buffer[loc-1]=62)THEN GOTO 30;
END;
END;
30:
skipahead:=c;
END;
PROCEDURE skipcomment;
LABEL 10;
VAR bal:eightbits;
c:asciicode;
BEGIN
bal:=0;
WHILE true DO
BEGIN
IF loc>limit THEN
BEGIN
getline;
IF buffer[0]=12 THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! PAGE ENDED IN MID-COMMENT');
END;
error;
END;
loc:=1;
GOTO 10;
END;
END;
c:=buffer[loc];
loc:=loc+1;
IF c=64 THEN
BEGIN
c:=buffer[loc];
IF(c<>32)AND(c<>9)AND(c<>42)THEN loc:=loc+1
ELSE
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! MODULE ENDED IN MID-COMMENT');
END;
error;
END;
loc:=loc-1;
GOTO
10;
END
END
ELSE IF(c=92)AND(buffer[loc]<>64)THEN loc:=loc+1
ELSE IF c=123 THEN bal:=bal+1
ELSE IF c=126 THEN
BEGIN
IF bal=0 THEN GOTO 10;
bal:=bal-1;
END;
END;
10:
END;
FUNCTION getnext:eightbits;
LABEL 20,30;
VAR c:eightbits;
d:eightbits;
j,k:0..longestname;
BEGIN
20:
IF loc>limit THEN
getline;
c:=buffer[loc];
loc:=loc+1;
CASE c OF
65,66,67,68,69,70,71,72,73,
74,75,76,77,78,79,80,81,82,83,84,85,
86,87,88,89,90,97,98,99,100,101,102,
103,104,105,106,107,108,109,110,111,112,
113,114,115,116,117,118,119,120,121,122:
BEGIN
loc:=loc-1;
idfirst:=loc;
REPEAT loc:=loc+1;
d:=buffer[loc];
UNTIL((d<48)OR((d>57)AND(d<65))
OR((d>90)AND(d<97))OR(d>122))AND(d<>24);
IF loc>idfirst+1 THEN
BEGIN
c:=130;
idloc:=loc;
END;
END;
34:
BEGIN
doublechars:=0;
idfirst:=loc-1;
REPEAT d:=buffer[loc];
loc:=loc+1;
IF(d=34)
OR(d=64)THEN
IF buffer[loc]=d THEN
BEGIN
loc:=loc+1;
d:=0;
doublechars:=doublechars+1;
END
ELSE IF d=64 THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! DOUBLE @ SIGN MISSING');
END;
error;
END
ELSE IF loc>limit THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! STRING CONSTANT DIDN''T END');
END;
error;
END;
d:=34;
END;
UNTIL d=34;
idloc:=loc-1;
c:=130;
END;
64:
BEGIN
c:=controlcode(buffer[loc]);
loc:=loc+1;
IF c=0 THEN GOTO 20
ELSE IF c=135 THEN
BEGIN
k:=0;
WHILE true DO
BEGIN
IF loc>limit THEN
BEGIN
getline;
IF buffer[0]=12 THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! PAGE ENDED IN MODULE NAME');
END;
error;
END;
loc:=1;
GOTO 30;
END;
END;
d:=buffer[loc];
IF d=64 THEN
BEGIN
d:=buffer[loc+1];
IF d=62 THEN
BEGIN
loc:=loc+2;
GOTO 30;
END;
IF(d=32)OR(d=9)OR(d=42)THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! MODULE NAME DIDN''T END');
END;
error;
END;
GOTO
30;
END;
k:=k+1;
module[k]:=64;
loc:=loc+1;
END;
loc:=loc+1;
IF k<longestname-1
THEN k:=k+1;
IF(d=32)OR(d=9)THEN
BEGIN
d:=32;
IF module[k-1]=32 THEN k:=k-1;
END;
module[k]:=d;
END;
30:
IF k>=longestname-2 THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! MODULE NAME TOO LONG: ');
END;
FOR j:=1 TO 25 DO
write(tty,chr(module[j]));
write(tty,'...');
END;
IF(module[k]=32)AND(k>0)THEN k:=k-1;
IF k>3 THEN
BEGIN
IF(module[k]=46)AND(module[k-1]=46)
AND(module[k-2]=46)THEN
curmodule:=prefixlookup(k-3)
ELSE curmodule:=modlookup(k);
END
ELSE curmodule:=modlookup(k);
END
ELSE IF c=131 THEN
BEGIN
REPEAT c:=skipahead;
UNTIL c<>64;
IF buffer[loc-1]<>62 THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! IMPROPER @ WITHIN @T...@>');
END;
error;
END;
GOTO 20;
END;
END;
46:IF buffer[loc]=46 THEN
BEGIN
c:=32;
loc:=loc+1;
END;
58:IF buffer[loc]=61 THEN
BEGIN
c:=95;
loc:=loc+1;
END;
61:IF buffer
[loc]=61 THEN
BEGIN c:=30;
loc:=loc+1;
END;
62:IF buffer[loc]=61 THEN
BEGIN
c:=29;
loc:=loc+1;
END;
60:IF buffer[loc]=61 THEN
BEGIN
c:=28;
loc:=loc+1;
END
ELSE IF buffer[loc]=62 THEN
BEGIN
c:=27;
loc:=loc+1;
END;
40:IF buffer[loc]=42 THEN
BEGIN
c:=9;
loc:=loc+1;
END;
42:IF buffer[loc]=41 THEN
BEGIN
c:=10;
loc:=loc+1;
END;
32,9:GOTO 20;
123:
BEGIN
skipcomment;
GOTO 20;
END;
12:c:=136;
OTHERS:
END;
IF troubleshoot THEN debughelp;
getnext:=c;
END;
PROCEDURE scannumeric(p:namepointer);
LABEL 21,30;
VAR
accumulator:integer;
nextsign:-1..+1;
q:namepointer;
val:integer;
PROCEDURE addin(v:integer);
BEGIN
accumulator:=accumulator+nextsign*v;
nextsign:=+1;
END;
BEGIN
accumulator:=0;
nextsign:=+1;
WHILE true DO
BEGIN
nextcontrol:=getnext;
21:
CASE nextcontrol OF
48,49,50,51,52,53,54,55,56,57:
BEGIN
val:=0;
REPEAT val:=10*val+nextcontrol-48;
nextcontrol:=getnext;
UNTIL(nextcontrol>57)OR(nextcontrol<48);
addin(val);
GOTO 21;
END;
12:
BEGIN
val:=0;
nextcontrol:=48;
REPEAT val:=8*val+nextcontrol-48;
nextcontrol:=getnext;
UNTIL(nextcontrol>55)OR(nextcontrol<48);
addin(val);
GOTO 21;
END;
130:
BEGIN
q:=idlookup(0);
IF ilk[q]<>1 THEN
BEGIN
nextcontrol:=42;
GOTO 21;
END;
addin(equiv[q]-32768);
END;
43:;
45:nextsign:=-nextsign;
132,133,135,134,136,137:GOTO 30;
59:
BEGIN
BEGIN
writeln(tty);
write(tty,'! OMIT SEMICOLON IN NUMERIC DEFINITION');
END;
error;
END;
OTHERS:
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! IMPROPER NUMERIC DEFINITION WILL BE FLUSHED');
END;
error;
END;
REPEAT
nextcontrol:=skipahead UNTIL(nextcontrol>=132);
IF nextcontrol=135 THEN
BEGIN
loc:=loc-2;
nextcontrol:=getnext;
END;
accumulator:=0;
GOTO 30;
END
END;
END;
30:;
IF abs(accumulator)>=32768 THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! VALUE TOO BIG: ',accumulator:0);
END;
error;
END;
accumulator:=0;
END;
equiv[p]:=accumulator+32768;
END;
PROCEDURE scanrepl(t:
eightbits);
LABEL 22,30,31;
VAR a:sixteenbits;
b:asciicode;
bal:eightbits;
BEGIN
bal:=0;
WHILE true DO
BEGIN
22:
a:=getnext;
CASE a OF
40:bal:=bal+1;
41:IF bal=0 THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! EXTRA )');
END;
error;
END
ELSE bal:=bal-1;
39:
BEGIN
b:=39;
WHILE true DO
BEGIN
BEGIN
IF tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=b;
tokptr:=tokptr+1;
END;
IF b=64 THEN
IF buffer[loc]=64 THEN
loc:=loc+1
ELSE
BEGIN
BEGIN
writeln(tty);
write(tty,'! YOU SHOULD DOUBLE @ SIGNS IN STRINGS');
END;
error;
END;
IF loc=limit THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! STRING DIDN''T END');
END;
error;
END;
buffer[loc]:=39;
buffer[loc+1]:=0;
END;
b:=buffer[loc];
loc:=loc+1;
IF b=39 THEN
BEGIN
IF buffer[loc]<>39 THEN GOTO 31
ELSE
BEGIN
loc:=loc+1;
BEGIN
IF tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=39;
tokptr:=tokptr+1;
END;
END;
END;
END;
31:
END;
35:IF t=3
THEN a:=13;
130:
BEGIN
a:=idlookup(0);
BEGIN
IF tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=(a DIV 256)+128;
tokptr:=tokptr+1;
END;
a:=a MOD 256;
END;
135:IF t<>135 THEN GOTO 30
ELSE
BEGIN
BEGIN
IF tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=(curmodule DIV 256)+168;
tokptr:=tokptr+1;
END;
a:=curmodule MOD 256;
END;
133,132,134:IF t<>135 THEN GOTO 30
ELSE
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! @',chr(buffer[loc-1]),' IS IGNORED IN PASCAL TEXT');
END;
error;
END;
GOTO 22;
END;
136,137:GOTO 30;
OTHERS:
END;
BEGIN
IF tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=a;
tokptr:=tokptr+1;
END;
END;
30:
nextcontrol:=a;
IF
bal>0 THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! MISSING ',bal:0,' )');
END;
error;
END;
WHILE bal>0 DO
BEGIN
BEGIN
IF tokptr=maxtoks THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TOKEN',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
tokmem[tokptr]:=41;
tokptr:=
tokptr+1;
END;
bal:=bal-1;
END;
END;
IF textptr=maxtexts THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! SORRY, ','TEXT',' CAPACITY EXCEEDED');
END;
error;
END;
quit;
END;
currepltext:=textptr;
textptr:=textptr+1;
tokstart[textptr]:=tokptr;
END;
PROCEDURE definemacro(t:eightbits);
VAR p:
namepointer;
BEGIN
p:=idlookup(t);
scanrepl(t);
equiv[p]:=currepltext;
textlink[currepltext]:=0;
END;
PROCEDURE scanmodule;
LABEL 30,10;
VAR p:namepointer;
BEGIN
modulecount:=modulecount+1;
nextcontrol:=0;
WHILE true DO
BEGIN
22:
WHILE nextcontrol<=132 DO
BEGIN
nextcontrol:=skipahead;
IF nextcontrol=135 THEN
BEGIN
loc:=loc-2;
nextcontrol:=getnext;
END;
END;
IF
nextcontrol<>133 THEN GOTO 30;
nextcontrol:=getnext;
IF nextcontrol<>130 THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,
'! DEFINITION FLUSHED, MUST START WITH ','IDENTIFIER OF LENGTH > 1');
END;
error;
END;
GOTO 22;
END;
nextcontrol:=getnext;
IF nextcontrol=61 THEN
BEGIN
scannumeric(idlookup(1));
GOTO 22;
END
ELSE IF nextcontrol=30 THEN
BEGIN
definemacro(2);
GOTO 22;
END
ELSE IF nextcontrol=40 THEN
BEGIN
nextcontrol:=getnext;
IF nextcontrol=35 THEN
BEGIN
nextcontrol:=getnext;
IF nextcontrol=41 THEN
BEGIN
nextcontrol:=getnext;
IF nextcontrol=61 THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! USE == FOR MACROS');
END;
error;
END;
nextcontrol:=30;
END;
IF nextcontrol=30 THEN
BEGIN
definemacro(3);
GOTO 22;
END;
END;
END;
END;
BEGIN
BEGIN
writeln(tty);
write(tty,'! DEFINITION FLUSHED SINCE IT STARTS BADLY');
END;
error;
END;
END;
30:;
CASE nextcontrol OF
134:p:=0;
135:
BEGIN
p:=curmodule;
REPEAT
nextcontrol:=getnext;
UNTIL nextcontrol<>43;
IF(nextcontrol<>61)AND(nextcontrol<>30)THEN
BEGIN
BEGIN
BEGIN
writeln(tty);
write(tty,'! PASCAL TEXT FLUSHED, = SIGN IS MISSING');
END;
error;
END;
REPEAT
nextcontrol:=skipahead;
UNTIL nextcontrol>=136;
GOTO 10;
END;
END;
OTHERS:
GOTO 10
END;
storetwobyte(53248+modulecount);
scanrepl(135);
IF p=0 THEN
BEGIN
textlink[lastunnamed]:=currepltext;
lastunnamed:=currepltext;
END
ELSE
IF equiv[p]=0 THEN equiv[p]:=currepltext
ELSE
BEGIN
p:=equiv[p];
WHILE textlink[p]<maxtexts DO p:=textlink[p];
textlink[p]:=currepltext;
END;
textlink[currepltext]:=maxtexts;
10:
END;
PROCEDURE debughelp;
LABEL 888;
VAR k:sixteenbits;
BEGIN
WHILE ddt<>0 DO
BEGIN
888:
CASE ddt OF
0:;
1:printid(dd);
2:printrepl(dd);
3:
BEGIN
BEGIN
writeln(tty);
write(tty,'*');
END;
error;
END;
4:FOR k:=1 TO dd DO write(tty,chr(module[k]));
5:FOR k:=1 TO dd DO write(tty,chr(outcontrib[k]));
OTHERS:
BEGIN
write(tty,'?');
read(tty,ddt);
END
END;
END;
END;
BEGIN
initialize;
IF openinput THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! COULDN''T OPEN THE INPUT FILE.');
END;
quit;
END;
page:=0;
line:=0;
limit:=0;
loc:=1;
buffer[0]:=32;
inputhasende:=false;
phaseone:=true;
modulecount:=0;
REPEAT nextcontrol:=skipahead;
WHILE nextcontrol=137 DO
scanmodule;
UNTIL inputhasende;
phaseone:=false;
maxtokptr:=tokptr;
IF textlink[0]=0 THEN
BEGIN
writeln(tty);
write(tty,'! NO OUTPUT WAS SPECIFIED.');
END
ELSE
BEGIN
BEGIN
writeln(tty);
write(tty,'WRITING THE OUTPUT FILE...');
END;
stackptr:=1;
bracelevel:=0;
curstate.namefield:=0;
curstate.replfield:=textlink[0];
curstate.bytefield:=tokstart[curstate.replfield];
curstate.endfield:=tokstart[curstate.
replfield+1];
outstate:=0;
outptr:=0;
breakptr:=0;
outbuf[0]:=0;
line:=1;
sendtheoutpu;
IF(outstate<>0)OR(outbuf[breakptr]<>46)THEN
BEGIN
BEGIN
writeln(tty);
write(tty,'! PROGRAM DIDN''T END WITH PERIOD');
END;
error;
END;
breakptr:=outptr;
flushbuffer;
BEGIN
writeln(tty);
write(tty,'DONE.');
END;
END;
9999:
IF stringptr>128 THEN
BEGIN
writeln(tty);
write(tty,stringptr-128:0,' STRINGS WRITTEN TO STRING POOL FILE.');
END;
BEGIN
writeln(tty);
write(tty,'MEMORY USAGE STATISTICS:');
END;
BEGIN
writeln(tty);
write(tty,nameptr:0,' NAMES, ',textptr:0,' REPLACEMENT TEXTS;');
END;
BEGIN
writeln(tty);
write(tty,byteptr:0,' BYTES, ',maxtokptr:0,' TOKENS.');
END;
END.